home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / dev / lang / pcq12src.lzh / Source / Main.p < prev    next >
Text File  |  1991-04-17  |  10KB  |  455 lines
  1. Program PCQ_Pascal;
  2.  
  3. {
  4.     PCQ Pascal Compiler
  5.     Copyright (c) 1989 Patrick Quaid.
  6.  
  7.     This is the main file of the compiler.  When this file is
  8. compiled, it allocates BSS for all the global variables.
  9. }
  10.  
  11. {$O-}
  12. {$I "Pascal.i"}
  13. {$I "Include:Utils/StringLib.i"}
  14. {$I "Include:Utils/Parameters.i"}
  15.  
  16.     { The following routines are all exported by the other
  17.       compiler files. }
  18.  
  19.     Procedure Error(s : string);
  20.         external;
  21.     Function CheckID(s : string): IDPtr;
  22.         external;
  23.  
  24.     Function EnterStandard(    st_Name : String;
  25.                 st_Object : IDObject;
  26.                 st_Type : TypePtr;
  27.                 st_Storage : IDStorage;
  28.                 st_Offset : Integer) : IDPtr;
  29.         external;
  30.  
  31.     Procedure NextSymbol;
  32.         external;
  33.     Function Match(s : Symbols): Boolean;
  34.         external;
  35.     Procedure DeclType;
  36.         external;
  37.     Procedure DeclConst;
  38.         external;
  39.     Procedure DeclLabel;
  40.         External;
  41.     Function DeclArgs(ob : IDObject) : IDPtr;
  42.         external;
  43.     Procedure ns;
  44.         external;
  45.     Procedure EnterID(CB : BlockPtr; ID : IDPtr);
  46.         external;
  47.     Procedure ReformArgs(ID : IDPtr);
  48.         external;
  49.     Function ReadType(): TypePtr;
  50.         external;
  51.     Function EndOfFile(): boolean;
  52.         external;
  53.     Function OpenInputFile(n : String) : Boolean;
  54.         external;
  55.     Procedure CloseInputFile;
  56.         external;
  57.     Procedure VarDeclarations;
  58.         external;
  59.     Procedure InitReserved;
  60.         external;
  61.     Procedure InitGlobals;
  62.         external;
  63.     Function GetLabel() : Integer;
  64.         External;
  65.     Procedure DumpIds;
  66.         external;
  67.     Procedure DumpRefs;
  68.         external;
  69.     Procedure DumpLits;
  70.         external;
  71.     Procedure Trailer;
  72.         external;
  73.     Procedure Compound;
  74.         external;
  75.     Procedure Header;
  76.         external;
  77.     Procedure InitStandard;
  78.         external;
  79.     Procedure ReadChar;
  80.         external;
  81.     Procedure NeedRightParent;            { Utilities.p }
  82.         external;
  83.     Function SimpleType(T : TypePtr): Boolean;    { Utilities.p }
  84.         external;
  85.     Procedure NewBlock;                { Utilities.p }
  86.         external;
  87.     Procedure KillBlock;                { Utilities.p }
  88.         external;
  89.     Procedure KillIDList(ID : IDPtr);        { Utilities.p }
  90.         external;
  91.     Procedure Decompose;                { Utilities.p }
  92.         external;
  93.     Function CompareProcs(Proc1, Proc2 : IDPtr) : Boolean;    { Utilities.p }
  94.         external;
  95.     Procedure BackUpSpell(Position : Integer);
  96.         external;
  97.     Procedure Out_Operation0(op : OpCodes);
  98.         External;
  99.     Procedure Out_Operation1(op : OpCodes; Size : Byte;
  100.                     EA : EAModes; Reg : Regs);
  101.         External;
  102.     Procedure Out_Operation2(op : OpCodes; Size : Byte;
  103.                     SrcEA : EAModes; SrcReg : Regs;
  104.                     DestEA : EAModes; DestReg : Regs);
  105.         External;
  106.     Procedure Out_Extension(Ext : Integer);
  107.         External;
  108.     Procedure FlushCodeTable;
  109.         External;
  110.  
  111.  
  112.  
  113. Procedure Banner;
  114. begin
  115.     writeln('PCQ Compiler 1.2 (April 18, 1991)');
  116.     writeln('Copyright ', chr(169),
  117.         ' 1989 Patrick Quaid.  All rights reserved.');
  118. end;
  119.  
  120. Procedure GetFileNames;
  121. var
  122.     Parm : String;
  123.     ParmNum : Short;
  124.  
  125.     Procedure Die(LastWords : string);
  126.     begin
  127.     Banner;
  128.     Writeln(LastWords);
  129.     Exit(20);
  130.     end;
  131.  
  132.     Procedure DoOption;
  133.     begin
  134.     if toupper(Parm[1]) = 'Q' then
  135.         Inform := False
  136.     else if toupper(Parm[1]) = 'B' then
  137.         ShortCircuit := False
  138.     else if toupper(Parm[1]) = 'S' then
  139.         SmallInitialize := True
  140.     else
  141.         Die("Unknown Directive");
  142.     end;
  143.  
  144. begin
  145.     Parm := AllocString(256);
  146.     MainName := Nil;
  147.     OutName := Nil;
  148.     ParmNum := 1;
  149.     repeat
  150.     GetParam(ParmNum, Parm);
  151.     if Parm^ = Chr(0) then begin
  152.         if MainName = Nil then
  153.         Die("No Input File Name");
  154.         if OutName = Nil then
  155.         Die("Missing Output File Name");
  156.     end else begin
  157.         if Parm^ = '-' then
  158.         DoOption
  159.         else if MainName = Nil then
  160.         MainName := strdup(Parm)
  161.         else if OutName = Nil then
  162.         OutName := strdup(Parm)
  163.         else
  164.         Die("Unknown Command");
  165.     end;
  166.     Inc(ParmNum);
  167.     until Parm^ = Chr(0);
  168.     FreeString(Parm);
  169. end;
  170.  
  171. Procedure OpenFiles;
  172. begin
  173.     InFile := nil;
  174.     if not OpenInputFile(MainName) then begin
  175.     Writeln('Could not open ', MainName);
  176.         Exit(20);
  177.     end;
  178.     if not open(OutName, OutFile, 10240) then begin
  179.     Writeln('Could not open ', OutName);
  180.     Exit(20);
  181.     end;
  182. end;
  183.  
  184. Procedure DoBlock(isfunction : boolean);
  185.  
  186.  
  187. {
  188.     This is the main routine for handling program, procedure
  189. and function blocks.  It handles the various declaration blocks and
  190. the procedure and function parameters.  This is one of the many
  191. routines which should, and will, be broken into more manageable
  192. parts.
  193. }
  194.  
  195. var
  196.     ID        : IDPtr;
  197.     DupID    : IDPtr;
  198.     savefn    : IDPtr;
  199.     ForwardID   : IDRec;
  200.     Forwarded    : Boolean;
  201.     FirstVar    : IDPtr;
  202.     SaveStack    : Integer;
  203.     SaveSpell    : Integer;
  204.     SaveKidCall : Boolean;
  205. begin
  206.     fnstart := lineno;
  207.     Forwarded := False;
  208.     FirstVar := Nil;
  209.     if CurrentBlock^.Level > 0 then begin
  210.     if currsym <> ident1 then begin
  211.         error("Missing function or procedure name!");
  212.         return;
  213.     end;
  214.     CurrFn := CheckID(symtext);
  215.     if CurrFn <> Nil then begin
  216.         if CurrFn^.Storage <> st_forward then
  217.         error("Duplicate ID")
  218.         else begin
  219.         ForwardID := CurrFn^;
  220.         Forwarded := True;
  221.         CurrFn^.Param := Nil;
  222.         end;
  223.     end else begin
  224.         case isfunction of
  225.         True : CurrFn := EnterStandard(symtext, func, Nil, st_none, 0);
  226.         False: CurrFn := EnterStandard(symtext, proc, Nil, st_none, 0);
  227.         end;
  228.         CurrFn^.Unique := GetLabel();
  229.     end;
  230.     nextsymbol;
  231.     SaveSpell := SpellPtr;
  232.  
  233.     if Match(leftparent1) then begin
  234.         CurrFn^.Param := DeclArgs(valarg); { Dummy param here }
  235.         ReformArgs(CurrFn); { Set offsets of args, plus totalsize }
  236.         NeedRightParent;
  237.     end else
  238.         CurrFn^.Param := Nil;
  239.  
  240.     if isfunction then begin
  241.         if not match(colon1) then
  242.         error("expecting :");
  243.         CurrFn^.VType := readtype();
  244.         if not simpletype(CurrFn^.VType) then begin
  245.         error("expecting a simple type");
  246.         CurrFn^.VType := BadType;
  247.         end;
  248.     end;
  249.     ns;
  250.     end;
  251.  
  252.     if match(forward1) then begin
  253.     if Forwarded then
  254.         Error("Already declared");
  255.     CurrFn^.Storage := st_forward;
  256.     ns;
  257.     end else if Match(extern1) then begin
  258.     CurrFn^.Storage := st_external;
  259.     ns;
  260.     end else begin
  261.     if Forwarded then begin
  262.         if not CompareProcs(Adr(ForwardID), CurrFn) then
  263.         Error("Definitions do not match");
  264.         KillIDList(ForwardID.Param);
  265.     end;
  266.     NewBlock;
  267.     if CurrentBlock^.Level > 1 then begin
  268.         CurrFn^.Storage := st_internal;
  269.         ID := CurrFn^.Param;
  270.         while ID <> nil do begin
  271.         New(DupID);
  272.         DupID^ := ID^;
  273.         ID^.Name := Nil;
  274.         EnterID(CurrentBlock, DupID);
  275.         ID := ID^.Next;
  276.         end;
  277.     end;
  278.  
  279.     StackSpace := 0;
  280.  
  281.     while currsym <> begin1 do begin
  282.         if endoffile() then begin
  283.         if mainmode or (CurrentBlock^.Level > 1) then
  284.             error("There was no code section!");
  285.         return;
  286.         end else if match(var1) then
  287.         VarDeclarations
  288.         else if match(type1) then
  289.         DeclType
  290.         else if match(const1) then
  291.         DeclConst
  292.         else if match(proc1) then begin
  293.         savefn := currfn;
  294.         SaveStack := StackSpace;
  295.         doblock(false);
  296.         StackSpace := SaveStack;
  297.         currfn := savefn;
  298.         end else if match(func1) then begin
  299.         savefn := currfn;
  300.         SaveStack := StackSpace;
  301.         doblock(true);
  302.         StackSpace := SaveStack;
  303.         currfn := savefn;
  304.         end else if match(label1) then
  305.         DeclLabel
  306.         else begin
  307.         error("expecting block identifier");
  308.         nextsymbol;
  309.         end;
  310.     end;
  311.  
  312.     if CurrentBlock^.Level > 1 then begin
  313.         if odd(StackSpace) then
  314.         StackSpace := Succ(StackSpace);
  315.         CurrFn^.Offset := StackSpace;
  316.     end;
  317.  
  318.     if (not mainmode) and (CurrentBlock^.Level = 1) then begin
  319.         error("Expected a procedure or function header");
  320.         return;
  321.     end;
  322.  
  323.     NextCode := 0;
  324.  
  325.     Writeln(OutFile, '\tCNOP\t0,2');
  326.     case CurrentBlock^.Level of
  327.       1 : if MainMode then begin
  328.           writeln(OutFile, '_MAIN');
  329.           end;
  330.       2 : begin
  331.           if StandardStorage <> st_private then
  332.               writeln(OutFile, "\n\tXDEF\t_", CurrFn^.Name);
  333.           Writeln(OutFile, '_', CurrFn^.Name);
  334.  
  335.           Out_Operation2(op_LINK,3,ea_Register,a5,ea_Constant,a7);
  336.           Out_Extension(-CurrFn^.Offset);
  337.           Out_Operation0(op_SAVE);
  338.           end;
  339.     else begin
  340.          Writeln(OutFile, '_', CurrFn^.Name, '%', CurrFn^.Unique);
  341.          Out_Operation2(op_LINK,3,ea_Register,a5,ea_Constant,a7);
  342.          Out_Extension(-CurrFn^.Offset);
  343.          Out_Operation0(op_SAVE);
  344.          end;
  345.     end;
  346.     NextSymbol;
  347.     MathLoaded   := False;
  348.  
  349.     Compound;
  350.  
  351.     if CurrentBlock^.Level > 1 then begin
  352.         ns;
  353.         Out_Operation0(op_RESTORE);
  354.         Out_Operation1(op_UNLK,3,ea_Register,a5);
  355.         Out_Operation0(op_RTS);
  356.  
  357.         FlushCodeTable;  { Must be done BEFORE KillBlock - it uses ID's }
  358.  
  359.         KillBlock;
  360.         BackUpSpell(SaveSpell);
  361.     end else begin
  362.         Out_Operation0(op_RTS);
  363.         FlushCodeTable;
  364.     end;
  365.     end;
  366. end;
  367.  
  368.  
  369. Procedure Parse;
  370.  
  371. {
  372.     This is the outermost parsing routine.  It uses doblock()
  373. mainly, and will eventually be able to handle program parameters.
  374. }
  375.  
  376. begin
  377.     if Match(program1) then begin
  378.     mainmode:= true;
  379.     StandardStorage := st_internal;
  380.     if currsym = ident1 then
  381.         NextSymbol { Eat program name }
  382.     else
  383.         error("Missing program name.");
  384.     if Match(LeftParent1) then begin
  385.         while CurrSym = Ident1 do begin
  386.         NextSymbol;
  387.         if CurrSym <> RightParent1 then
  388.             if not Match(Comma1) then
  389.             Error("Expecting a comma");
  390.         end;
  391.         NeedRightParent;
  392.     end;
  393.     ns;
  394.     end else if match(extern1) then begin
  395.     mainmode := false;
  396.     StandardStorage := st_external;
  397.     ns;
  398.     end else begin
  399.     error("First symbol must be PROGRAM or EXTERNAL.");
  400.     StandardStorage := st_internal;
  401.     MainMode:= false;
  402.     end;
  403.     Header;
  404.     DoBlock(false);
  405.     if MainMode then
  406.     if not Match(period1) then
  407.         Error("Program must end with a period.");
  408.     if (not EndOfFile) and (MainMode) then
  409.     Error("There should be nothing after the main procedure.");
  410. end;
  411.  
  412. begin
  413.  
  414. {
  415.     This is the big one, the main routine, which by itself does
  416. very little.  Read parse() and doblock() to get a much better idea
  417. of how things work.
  418. }
  419.  
  420.     initglobals;    { initialize everything }
  421.     initreserved;
  422.     initstandard;
  423.  
  424.     GetFileNames;
  425.     if Inform then
  426.     Banner;
  427.     OpenFiles;
  428.  
  429.     nextsymbol;
  430.  
  431.     parse;     { do everything }
  432.  
  433.     if Inform then begin
  434.     if errorcount = 0 then
  435.         writeln('There were no errors.')
  436.     else if errorcount = 1 then
  437.         writeln('There was one error')
  438.     else
  439.         writeln('There were ', errorcount, ' errors.');
  440.     end;
  441.  
  442.     DumpRefs;
  443.     DumpLits;
  444.     DumpIds;        { write IDs and literals to assem file }
  445.     trailer;        { write 'END' }
  446.     while InFile <> nil do
  447.     CloseInputFile;    { be sure to close the main file }
  448.  
  449. {    if Do_Offsets then
  450.     Decompose;     Write offset information }
  451.  
  452.     if errorcount <> 0 then
  453.     exit(10);    { make sure there's an error if necessary }
  454. end.
  455.